home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1999 April / macformat-075.iso / Shareware Plus / Applications / Alpha / Tcl / SystemCode / CorePackages / cache.tcl < prev    next >
Encoding:
Text File  |  1999-01-16  |  10.1 KB  |  365 lines  |  [TEXT/ALFA]
  1. ## -*-Tcl-*-
  2.  # ###################################################################
  3.  #  Vince's Additions - an extension package for Alpha
  4.  # 
  5.  #  FILE: "cache.tcl"
  6.  #                                    created: 17/7/97 {3:21:07 pm} 
  7.  #                                last update: 16/1/1999 {2:34:09 pm} 
  8.  #  Author: Vince Darley
  9.  #  E-mail: <darley@fas.harvard.edu>
  10.  #    mail: Division of Engineering and Applied Sciences, Harvard University
  11.  #          Oxford Street, Cambridge MA 02138, USA
  12.  #     www: <http://www.fas.harvard.edu/~darley/>
  13.  #  
  14.  # Copyright (c) 1997-1998  Vince Darley, all rights reserved
  15.  # 
  16.  # Usage:
  17.  # 
  18.  #  cache::create 'name'
  19.  #  cache::add 'name' variable var1 var2 ...
  20.  #  cache::add 'name' eval "beep" "menu Blah {}" ...
  21.  # 
  22.  # then:
  23.  # 
  24.  #  if {[cache::exists 'name']} {
  25.  #         cache::read 'name'
  26.  #         puts "var1 = $var1, var2 = $var2"
  27.  #         puts "Also I beeped and created a menu 'Blah'"
  28.  #  }
  29.  # 
  30.  # Alternatively, and useful when, say, you want to store lots of little 
  31.  # pieces of information, each with a different name (not really
  32.  # associated with a particular variable, though), you can do this:
  33.  # 
  34.  #  cache::snippetWrite 'item1' value1
  35.  #  cache::snippetWrite 'item2' value2
  36.  #  
  37.  # then:
  38.  # 
  39.  #  puts [cache::snippetRead item1]
  40.  #  puts [cache::snippetRead item2]
  41.  #  
  42.  # This is useful if you wish to build up a large menu from lots of
  43.  # little pieces, each of which is cached separately, because they
  44.  # may all change individually.
  45.  # 
  46.  # There are also procs to delete a cache, remove a snippet, or find
  47.  # out which variables are stored in a cache.
  48.  #  
  49.  #  modified by  rev reason
  50.  #  -------- --- --- -----------
  51.  #  17/7/97  VMD 1.0 split off from filesetsMenu.tcl; improved version.
  52.  # ###################################################################
  53.  ##
  54.  
  55. namespace eval cache {}
  56. # so if we make incompatible changes we can automatically delete
  57. # or re-interpret incompatible caches.
  58. set cache::version 1.0
  59.  
  60. ## 
  61.  # -------------------------------------------------------------------------
  62.  # 
  63.  # "cache::exists" --
  64.  # 
  65.  #  Is there a cache with the given name
  66.  # -------------------------------------------------------------------------
  67.  ##
  68. proc cache::exists {name} {
  69.     return [file exists [cache::name $name]]
  70. }
  71.  
  72. ## 
  73.  # -------------------------------------------------------------------------
  74.  # 
  75.  # "cache::read" --
  76.  # 
  77.  #  Read all the information from the given cache, into the _current_
  78.  #  execution level.  If you're in a proc and you want to read the
  79.  #  cache (or some of it) into global variables, you must precede
  80.  #  this call with a 'global' statement.
  81.  #  
  82.  #  If the cache doesn't exist this proc will give an error.
  83.  #  Use 'cache::exists' first to check.
  84.  # -------------------------------------------------------------------------
  85.  ##
  86. if {[info tclversion] < 8.0} {
  87.     proc cache::read {name} {
  88.     uplevel 1 {set cache::eval 1}
  89.     uplevel 1 [list source [cache::name $name]]
  90.     uplevel 1 {unset cache::eval}
  91.     }
  92. } else {
  93.     proc cache::read {name} {
  94.     uplevel 1 {namespace eval cache {}}
  95.     uplevel 1 {set cache::eval 1}
  96.     uplevel 1 [list source [cache::name $name]]
  97.     uplevel 1 {unset cache::eval}
  98.     }
  99. }
  100.  
  101. ## 
  102.  # -------------------------------------------------------------------------
  103.  # 
  104.  # "cache::readItem" --
  105.  # 
  106.  #  Read the value of a single cached item.  Not very efficient.  If you
  107.  #  want to do this a lot, you should think about storing 'snippets'
  108.  #  using the cache::snippetRead/Write procedures.
  109.  # -------------------------------------------------------------------------
  110.  ##
  111. proc cache::readItem {name item} {
  112.     set cache::eval 0
  113.     source [cache::name $name]
  114.     return [set $item]
  115. }
  116.  
  117. ## 
  118.  # -------------------------------------------------------------------------
  119.  # 
  120.  # "cache::variables" --
  121.  # 
  122.  #  Returns a list of the variables stored in the given cache
  123.  # -------------------------------------------------------------------------
  124.  ##
  125. proc cache::variables {name} {
  126.     set cache::eval 0
  127.     source [cache::name $name]
  128.     return [lremove [info vars *] cache::eval name]
  129. }
  130.  
  131. ## 
  132.  # -------------------------------------------------------------------------
  133.  # 
  134.  # "cache::create" --
  135.  # 
  136.  #  Write the given cache name with the given value.  If any other arguments
  137.  #  are given, they are the names of other variables/arrays which should
  138.  #  also be stored.
  139.  # -------------------------------------------------------------------------
  140.  ##
  141. proc cache::create {name args} {
  142.     close [cache::open $name create]
  143.     if {[llength $args]} {
  144.     uplevel 1 "cache::add [list $name] $args"
  145.     }
  146. }
  147.  
  148. proc cache::delete {args} {
  149.     foreach name $args {
  150.     if {[cache::exists $name]} {
  151.         catch {file delete [cache::name $name]}
  152.     }
  153.     }
  154. }
  155.  
  156. proc cache::deletePat {name} {
  157.     foreach f [glob -nocomplain [cache::name $name]] {
  158.     catch {file delete $f}
  159.     }
  160. }
  161.  
  162. if {[info tclversion] < 8.0} {
  163.     proc cache::name {name} {
  164.     global PREFS
  165.     regsub -all "::" $name ":" name
  166.     return "${PREFS}:Cache:${name}"
  167.     }
  168. } else {
  169.     # fix things up for cross-platform tcl 8
  170.     proc cache::name {name} {
  171.     global PREFS
  172.     if {[regexp {(.*)::[^:]+} $name "" ns]} {
  173.         # currently only allows one level of nesting
  174.         uplevel 2 "namespace eval $ns {}"
  175.         regsub -all "::" $name ":" name
  176.         set name [eval file join [split $name :]]
  177.     }
  178.     return [file join ${PREFS} Cache ${name}]
  179.     }
  180. }
  181.  
  182. ## 
  183.  # -------------------------------------------------------------------------
  184.  # 
  185.  # "cache::add" --
  186.  # 
  187.  #  Write additional information into a pre-existing cache.  The other
  188.  #  arguments are just variable names to store, if type is 'variable'.
  189.  #  Otherwise they are strings to be evaluated, if type is 'eval'.
  190.  # -------------------------------------------------------------------------
  191.  ##
  192. proc cache::add {name type args} {
  193.     set fcache [cache::open $name append]
  194.     switch -- $type {
  195.     "variable" {
  196.         foreach a $args {
  197.         upvar $a var
  198.         if {[array exists var]} {
  199.             foreach n [array names var] {
  200.             puts $fcache [list set ${a}(${n}) [set var(${n})]]
  201.             }
  202.         } else {
  203.             if {[info exists var]} {
  204.             puts $fcache [list set $a [set var]]
  205.             }
  206.         }
  207.         }
  208.     }
  209.     "eval" {
  210.         foreach a $args {
  211.         puts $fcache [list if \$\{cache::eval\} [list eval $a]]
  212.         }
  213.     }
  214.     }
  215.     close $fcache
  216. }
  217.  
  218. ## 
  219.  # -------------------------------------------------------------------------
  220.  # 
  221.  # "cache::open" --
  222.  # 
  223.  #  You shouldn't really call this procedure.  Call the others.
  224.  # -------------------------------------------------------------------------
  225.  ##
  226. proc cache::open {name {action "create"}} {
  227.     file::ensureDirExists [file dirname [set c [cache::name $name]]]
  228.     switch -- $action {
  229.     "create" {
  230.         if {[info tclversion] < 8.0} {
  231.         set fcache [open $c w]
  232.         } else {
  233.         set fcache [::open $c w]
  234.         }
  235.         puts $fcache "# -*-Tcl-*- (nowrap)"
  236.         global cache::version
  237.         puts $fcache "# Cache v${cache::version} created on [mtime [now]]"
  238.     }
  239.     "append" {
  240.         if {![file exists $c]} {close [cache::open $name create]}
  241.         if {[info tclversion] < 8.0} {
  242.         set fcache [open $c a]
  243.         } else {
  244.         set fcache [::open $c a]
  245.         }
  246.     }
  247.     "read" {
  248.         if {![file exists $c]} {close [cache::open $name create]}
  249.         if {[info tclversion] < 8.0} {
  250.         set fcache [open $c r]
  251.         } else {
  252.         set fcache [::open $c r]
  253.         }
  254.     }
  255.     default {
  256.         error "No such cache action '$action'"
  257.     }
  258.     }
  259.     return $fcache
  260. }
  261.  
  262. ## 
  263.  # -------------------------------------------------------------------------
  264.  # 
  265.  # "cache::snippetWrite" --
  266.  # 
  267.  #  Store a small snippet $value, using '$name' as an identifier with
  268.  #  which to retrieve it later.
  269.  #  
  270.  #  Snippets are stored efficiently in a single file, and retrieved
  271.  #  by examining the contents of that file directly.  This is
  272.  #  quicker than setting/unsetting lots of vars if you wish to
  273.  #  ask for a variety of snippets in different places in your
  274.  #  code.
  275.  #  
  276.  #  I think this proc works ok with all the weird characters, but
  277.  #  I may have missed something.
  278.  # -------------------------------------------------------------------------
  279.  ##
  280. proc cache::snippetWrite {name value {file "_snippet_"}} {
  281.     cache::readFile $file contents
  282.     set reg [quote::Regfind [list set _snippet_cache(${name})]]
  283.     if {[regsub "$reg (\[^\n\]*)\n" $contents "[list set _snippet_cache(${name}) [quote::Regsub $value]]\n" contents]} {
  284.     cache::writeFile $file contents
  285.     } else {
  286.     set "_snippet_cache($name)" $value
  287.     cache::add $file "variable" _snippet_cache($name)
  288.     }
  289. }
  290.  
  291. ## 
  292.  # -------------------------------------------------------------------------
  293.  # 
  294.  # "cache::snippetRead" --
  295.  # 
  296.  #  Retrieve a previously stored snippet.
  297.  # -------------------------------------------------------------------------
  298.  ##
  299. proc cache::snippetRead {name {file "_snippet_"}} {
  300.     cache::readFile $file contents
  301.     set reg [quote::Regfind [list set _snippet_cache(${name})]]
  302.     if {[regexp "$reg (\[^\n\]*)\n" $contents "" val]} {
  303.     eval return $val
  304.     } else {
  305.     return ""
  306.     }
  307. }
  308.  
  309. proc cache::snippetRemove {name {file "_snippet_"}} {
  310.     cache::readFile $file contents
  311.     set reg [quote::Regfind [list set _snippet_cache(${name})]]
  312.     if {[regsub "$reg (\[^\n\]*)\n" $contents "" contents]} {
  313.     cache::writeFile $file contents
  314.     }
  315. }
  316.  
  317.  
  318. ## 
  319.  # -------------------------------------------------------------------------
  320.  # 
  321.  # "cache::readFile" --
  322.  # 
  323.  #  Read the entire contents of a cache into the given variable
  324.  # -------------------------------------------------------------------------
  325.  ##
  326. proc cache::readFile {name contents} {
  327.     set f [cache::name $name]
  328.     upvar $contents c
  329.     if {[file exists $f] && [file readable $f]} {
  330.     if {[info tclversion] < 8.0} {
  331.         set fileid [open $f "r"]
  332.         set c [read $fileid]
  333.         close $fileid
  334.     } else {
  335.         set fileid [::open $f "r"]
  336.         set c [::read $fileid]
  337.         ::close $fileid
  338.     }
  339.     } else {
  340.     set c ""
  341.     }
  342. }
  343.  
  344. ## 
  345.  # -------------------------------------------------------------------------
  346.  # 
  347.  # "cache::writeFile" --
  348.  # 
  349.  #  Overwrite a cache with the value of the given variable 
  350.  # -------------------------------------------------------------------------
  351.  ##
  352. proc cache::writeFile {name contents} {
  353.     upvar $contents c
  354.     if {[info tclversion] < 8.0} {
  355.     set fileid [open [cache::name $name] "w"]
  356.     } else {
  357.     set fileid [::open [cache::name $name] "w"]
  358.     }
  359.     puts -nonewline $fileid $c
  360.     close $fileid
  361. }
  362.  
  363.  
  364.  
  365.